home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue32 / system / UMouseDemo.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1998-04-06  |  4.3 KB  |  123 lines
  1. unit UMouseDemo;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   StdCtrls, ComCtrls, ExtCtrls;
  8.  
  9. type
  10.     TForm1 = class(TForm)
  11.     Panel1: TPanel;
  12.     procedure FormCreate(Sender: TObject);
  13.     private
  14.         { Private declarations }
  15.         fIntelliWheelSupport: Boolean;    // True if IntelliMouse + wheel enabled
  16.         fIntelliMessage: UINT;            // message sent from mouse on wheel roll
  17.         fIntelliScrollLines: Integer;     // number of lines to scroll per wheel roll
  18.         procedure IntelliMouseInit;
  19.         procedure WndProc (var Message: TMessage); override;
  20.         procedure WMMouseWheel (var Message: TMessage); message wm_MouseWheel;
  21.     public
  22.         { Public declarations }
  23.     end;
  24.  
  25. var
  26.     Form1: TForm1;
  27.  
  28. implementation
  29.  
  30. {$R *.DFM}
  31.  
  32. procedure TForm1.FormCreate(Sender: TObject);
  33. begin
  34.     IntelliMouseInit;
  35. end;
  36.  
  37. procedure TForm1.WndProc (var Message: TMessage);
  38.  
  39.     function GetShiftState: Integer;
  40.     begin
  41.         Result := 0;
  42.         if GetAsyncKeyState (vk_Shift)   < 0 then Result := Result or mk_Shift;
  43.         if GetAsyncKeyState (vk_Control) < 0 then Result := Result or mk_Control;
  44.         if GetAsyncKeyState (vk_LButton) < 0 then Result := Result or mk_LButton;
  45.         if GetAsyncKeyState (vk_RButton) < 0 then Result := Result or mk_RButton;
  46.         if GetAsyncKeyState (vk_MButton) < 0 then Result := Result or mk_MButton;
  47.     end;
  48.  
  49. begin
  50.     { If the message is non-native, eat the non-native message and post a native }
  51.     { message.  We don't call Inherited, thus ensuring original message is discarded. }
  52.     if (Message.Msg = fIntelliMessage) and (fIntelliMessage <> wm_MouseWheel) then begin
  53.         { We need to convert the non-native info into native format.  Bleugh! }
  54.         PostMessage (Handle, wm_MouseWheel, MakeLong (GetShiftState, Message.wParam), Message.lParam);
  55.     end else Inherited;
  56. end;
  57.  
  58. procedure TForm1.WMMouseWheel (var Message: TMessage);
  59. const
  60.     Delta: SmallInt = 0;
  61. var
  62.     Idx: Integer;
  63. begin
  64.     Delta := Delta + HiWord (Message.wParam);
  65.     while Abs(Delta) >= 120 do begin
  66.         if Delta < 0 then begin
  67.             for Idx := 0 to fIntelliScrollLines - 1 do
  68.                 PostMessage (Handle, wm_VScroll, MakeLong (sb_LineDown, 0), 0);
  69.             Delta := Delta + 120;
  70.         end else begin
  71.             for Idx := 0 to fIntelliScrollLines - 1 do
  72.                 PostMessage (Handle, wm_VScroll, MakeLong (sb_LineUp, 0), 0);
  73.             Delta := Delta - 120;
  74.         end;
  75.     end;
  76. end;
  77.  
  78. procedure TForm1.IntelliMouseInit;
  79. var
  80.     hWndMouse: hWnd;
  81.     mQueryScrollLines: UINT;
  82.  
  83.     function NativeMouseWheelSupport: Boolean;
  84.     var
  85.         ver: TOSVersionInfo;
  86.     begin
  87.         Result := False;
  88.         ver.dwOSVersionInfoSize := sizeof (ver);
  89.         // For Windows 98, assume dwMajorVersion = 5 (It's 4 for W95)
  90.         // For NT, we need 4.0 or better.
  91.         if GetVersionEx (ver) then case ver.dwPlatformID of
  92.             ver_Platform_Win32_Windows: Result := ver.dwMajorVersion >= 5;
  93.             ver_Platform_Win32_NT:      Result := ver.dwMajorVersion >= 4;
  94.         end;
  95.  
  96.         { Quick and dirty temporary hack for Windows 98 beta 3 }
  97.         if (Result = False) and (ver.szCSDVersion = ' Beta 3') then Result := True;
  98.     end;
  99.  
  100. begin
  101.     if NativeMouseWheelSupport then begin
  102.         fIntelliWheelSupport := Boolean (GetSystemMetrics (sm_MouseWheelPresent));
  103.         SystemParametersInfo (spi_GetWheelScrollLines, 0, @fIntelliScrollLines, 0);
  104.         fIntelliMessage := wm_MouseWheel;
  105.     end else begin
  106.         { Look for hidden mouse window }
  107.         hWndMouse := FindWindow ('MouseZ', 'Magellan MSWHEEL');
  108.         if hWndMouse <> 0 then begin
  109.             { We're in business - get the scroll line info }
  110.             fIntelliWheelSupport := True;
  111.             mQueryScrollLines := RegisterWindowMessage ('MSH_SCROLL_LINES_MSG');
  112.             fIntelliScrollLines := SendMessage (hWndMouse, mQueryScrollLines, 0, 0);
  113.             { Finally, get the custom mouse message as well }
  114.             fIntelliMessage := RegisterWindowMessage ('MSWHEEL_ROLLMSG');
  115.         end;
  116.     end;
  117.  
  118.     if (fIntelliScrollLines < 0) or (fIntelliScrollLines > 100) then fIntelliScrollLines := 3;
  119. end;
  120.  
  121. end.
  122.  
  123.